Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/puzzle/statepos.cls

Visual Basic class definition | 1999-09-07 | 7.7 KB | 254 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Stateposition"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Dim position(3, 3) As Integer          ' 2-dimensional array that holds current state

Dim children() As New Stateposition    ' dynamic array of children

Public step As Integer                 ' current depth of evaluation

Public closed As Boolean               ' indicates that all children were expanded

Public parent As Stateposition         ' pointer to a parent position
Public curvalue As Integer

Public xempty As Integer               ' x and y coordinate of an empty
Public yempty As Integer               ' tile in an array

Public onpath As Boolean               ' indicator that this state is on solution path

Public numberchildren As Integer       ' number of states possibly derived

Public last As Integer                 '  indicates the move that brought to
                                       ' this position

Public nextstate As New Stateposition

Private Sub Class_Initialize()
                           ' initially state is not closed and not on solution path
                           ' to be maximum
 closed = False
 numberchildren = 0
 onpath = False
End Sub

' evaluation function. curvalue equals to sum of distances of all displaced tiles and
' current depth of evaluation (step). Returns true for final solution ,false otherwise

Public Function evaluate() As Boolean

 Dim i As Integer
 Dim j As Integer
 Dim x As Integer
 Dim temp As Integer

 curvalue = step       ' initialize curvalue to step

 For i = 0 To 2
   For j = 0 To 2
      temp = 3 * i + j          ' value supposed to be in (i,j) in array

      If (temp = position(i, j)) Then          ' Tile is in place

      ElseIf (Not position(i, j) = 0) Then     ' evaluating displacement distance

        curvalue = curvalue + Math.Abs(position(i, j) \ 3 - i) _
         + Math.Abs((position(i, j) Mod 3) - j)
      End If
   Next
 Next
 If curvalue = step Then                ' means that this state is solution
   Puzzle.finished = True
   Puzzle.setpath Me
   evaluate = True
 Else
   evaluate = False
 End If
End Function

' Sub that copies array of tiles from parent to child

Public Sub makearray(temp() As Integer)
  Dim i As Integer
  Dim j As Integer

  For i = 0 To 2
   For j = 0 To 2
    position(i, j) = temp(i, j)
    If (temp(i, j) = 0) Then
     xempty = i                   ' Also copy the location of empty tile
     yempty = j
    End If
   Next
  Next

End Sub


' sub that expands all children of the state (breadth first) except of one that is identical
' to the states parent (to avoid repetitions).

Public Sub expandchildren()

   If (xempty > 0 And Not (last = 3)) Then           ' move empty tile up
    numberchildren = 1
    ReDim Preserve children(1)                       ' create child and add it to array
    Set children(0) = New Stateposition
    Set children(0).parent = Me
    children(0).step = Me.step + 1
    children(0).last = 1                             ' last move of the child was up
    children(0).makearray position
    children(0).makemove 1                           ' change state for a child
   End If

   If (yempty > 0 And Not (last = 4)) Then           ' the same but go left
    numberchildren = numberchildren + 1
    ReDim Preserve children(numberchildren)
    Set children(numberchildren - 1) = New Stateposition
    Set children(numberchildren - 1).parent = Me
    children(numberchildren - 1).step = Me.step + 1
    children(numberchildren - 1).last = 2
    children(numberchildren - 1).makearray position
    children(numberchildren - 1).makemove 2
   End If

   If (xempty < 2 And Not (last = 1)) Then          ' the same but go down
    numberchildren = numberchildren + 1
    ReDim Preserve children(numberchildren)
    Set children(numberchildren - 1) = New Stateposition
    Set children(numberchildren - 1).parent = Me
    children(numberchildren - 1).step = Me.step + 1
    children(numberchildren - 1).last = 3
    children(numberchildren - 1).makearray position
    children(numberchildren - 1).makemove 3
   End If

   If (yempty < 2 And Not (last = 2)) Then           ' the same but go right
    numberchildren = numberchildren + 1
    ReDim Preserve children(numberchildren)
    Set children(numberchildren - 1) = New Stateposition
    Set children(numberchildren - 1).parent = Me
    children(numberchildren - 1).step = Me.step + 1
    children(numberchildren - 1).last = 4
    children(numberchildren - 1).makearray position
    children(numberchildren - 1).makemove 4
   End If
End Sub

' sub that changes array of tiles of the current state according to the last move made (since
' we've copied array from parent we need to do it).

Public Sub makemove(flag As Integer)

  Select Case flag
  Case 1                         ' moving up
    position(xempty, yempty) = position(xempty - 1, yempty)
    position(xempty - 1, yempty) = 0

    xempty = xempty - 1
  Case 2                          ' moving left
    position(xempty, yempty) = position(xempty, yempty - 1)
    position(xempty, yempty - 1) = 0

    yempty = yempty - 1
  Case 3                         ' moving down
    position(xempty, yempty) = position(xempty + 1, yempty)
    position(xempty + 1, yempty) = 0

    xempty = xempty + 1
  Case 4                         ' moving right
    position(xempty, yempty) = position(xempty, yempty + 1)
    position(xempty, yempty + 1) = 0

    yempty = yempty + 1
  End Select

End Sub

 ' returns a child with correspondent index from array of children

Public Function getchild(index As Integer) As Stateposition
 Set getchild = children(index)
End Function

' shows current state and used only for debugging

Public Sub show()
 Dim i As Integer
 Dim j As Integer
 Dim temp As String
  For i = 0 To 2
   For j = 0 To 2
    temp = temp & " " & position(i, j)
   Next
   temp = temp & vbCrLf
  Next
  MsgBox temp

End Sub


' after finding solution path redraws state one by one from initial to the solution

Public Sub redrawstate()
 Dim x As Integer
 Dim y As Integer
 Dim index As Integer
 Dim num As Integer

 y = Puzzle.translatey(parent.xempty)
 x = Puzzle.translatex(parent.yempty)

  Select Case last
   Case 1                                   ' empty was moved up so find button beneath
                                           ' and move it up
    index = Puzzle.findbutton(x, y - 1320)
   Case 2
    index = Puzzle.findbutton(x - 1320, y)
   Case 3
    index = Puzzle.findbutton(x, y + 1320)
   Case 4
    index = Puzzle.findbutton(x + 1320, y)
  End Select

  For num = 7 To -1 Step -1
   If (last = 1) Then
    Puzzle.Command1(index).Move x, y - (num + 1) * 165
   ElseIf (last = 2) Then
    Puzzle.Command1(index).Move x - (num + 1) * 165, y
   ElseIf (last = 3) Then
    Puzzle.Command1(index).Move x, y + (num + 1) * 165
   ElseIf (last = 4) Then
    Puzzle.Command1(index).Move x + (num + 1) * 165, y
   End If
   Puzzle.Refresh
   Sleep 200
   DoEvents
  Next
End Sub

Public Sub freechild()             ' cleaning memory. sets references to
 Dim i As Integer                  ' all children and parents to nothing

  For i = 0 To numberchildren - 1
   Set children(i) = Nothing
  Next

  Set parent = Nothing
End Sub